home *** CD-ROM | disk | FTP | other *** search
/ Power Programmierung / Power-Programmierung (Tewi)(1994).iso / acad / autolisp / rect / rec.lsp
Lisp/Scheme  |  1989-09-24  |  8KB  |  158 lines
  1. ;;; -*-  Mode: LISP -*- Syntax: AutoLISP (C) Benjamin Olasov 1988, 1989
  2. ;;;      rectangle drawing
  3.  
  4. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  5. ;;; File: RECT.LSP Copyright (C) Benjamin Olasov    Graphic Systems, Inc.   ;;;
  6. ;;; Inquiries:                                                              ;;;
  7. ;;;                                                                         ;;;
  8. ;;;     Benjamin Olasov                                                     ;;;
  9. ;;;     Graphic Systems, Inc.:                                              ;;;
  10. ;;;                                                                         ;;;
  11. ;;;                    New York, NY:   PH (212) 725-4617                    ;;;
  12. ;;;                    Cambridge, MA:  PH (617) 492-1148                    ;;;
  13. ;;;                    MCI-Mail:       GSI-NY   344-4003                    ;;;
  14. ;;;                    Arpanet:        olasov@cs.columbia.edu               ;;;
  15. ;;;                                                                         ;;;
  16. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
  17.  
  18. ;; This program is provided 'as is' without warranty of any kind, either 
  19. ;; expressed or implied, including, but not limited to the implied warranties of
  20. ;; merchantability and fitness for a particular purpose.  The entire risk as to
  21. ;; the quality and performance of the program is with the user.  Should the 
  22. ;; program prove defective, the user assumes the entire cost of all necessary 
  23. ;; servicing, repair or correction. 
  24. ;; AutoLisp and AutoCad are registered trademarks of AutoDesk, Inc.
  25.  
  26.  
  27. ;; This program is provided 'as is' without warranty of any kind, either 
  28. ;; expressed or implied, including, but not limited to the implied warranties of
  29. ;; merchantability and fitness for a particular purpose.  The entire risk as to
  30. ;; the quality and performance of the program is with the user.  Should the 
  31. ;; program prove defective, the user assumes the entire cost of all necessary 
  32. ;; servicing, repair or correction. 
  33. ;; AutoLisp and AutoCad are registered trademarks of AutoDesk, Inc.
  34.  
  35. (gc)
  36. (vmon)
  37. (princ "\nPlease wait- loading.")
  38.  
  39. ;;REC draws a rectangle based on digitizing two corners and prompts for
  40. ;;the corner rounding radius.  The rounding radius can be digitized.
  41. ;;The default rounding radius is always 0.
  42.  
  43. (defun C:REC (/ ll lr ul ur rad)
  44.         (graphscr)
  45.         (setvar "blipmode" 1)
  46.         (setq ur (getcorner (setq ll (getpoint "\n\n\nFirst corner: "))
  47.                  "\nOther corner: "))
  48.         (setq ul (list (car ll) (cadr ur))
  49.               lr (list (car ur) (cadr ll))
  50.               rad (getdist "\nCorner round radius <0>: "))
  51.         (setvar "blipmode" 0)
  52.         (setvar "cmdecho" 0)
  53.         (if (or (null rad) (= rad 0))
  54.             (command "pline" ll "w" "0" "0" ul ur lr "c")
  55.             (command "pline" (polar ll (angle ll ul) rad) "w" "0" "0"
  56.                              (polar ul (angle ul ll) rad) "a" "d" ul
  57.                              (polar ul (angle ul ur) rad) "l"
  58.                              (polar ur (angle ur ul) rad) "a" "d" ur
  59.                              (polar ur (angle ur lr) rad) "l"
  60.                              (polar lr (angle lr ur) rad) "a" "d" lr
  61.                              (polar lr (angle lr ll) rad) "l"
  62.                              (polar ll (angle ll lr) rad) "a" "d" ll
  63.                              (polar ll (angle ll ul) rad) "cl"))
  64.         (setvar "cmdecho" 1) 'done)
  65.  
  66.  
  67. ;;RECT draws a rectangle based on digitizing the lower left corner and 
  68. ;;supplying X and Y dimensions.
  69. ;;The widths and rounding radius can either digitized or entered in dimension
  70. ;;format from the keyboard.
  71.  
  72. (defun C:RECT (/ ll lr ul ur rad)
  73.        (graphscr)
  74.        (setvar "cmdecho" 0)
  75.        (setvar "blipmode" 1)
  76.        (setq ll (getpoint "\nLower left corner of rectangle: "))
  77.        (setq width (getdist "\nEnter X dimension: ")
  78.              height (getdist "\nEnter Y dimension: "))
  79.        (setq lr (list (+ (car ll) width) (cadr ll))
  80.              ul (list (car ll) (+ (cadr ll) height))
  81.              ur (list (+ (car ll) width) (+ (cadr ll) height))
  82.              rad (getdist "\nCorner round radius <0>: "))
  83.        (setvar "blipmode" 0)
  84.        (if (or (null rad) (= rad 0))
  85.            (command "pline" ll "w" "0" "0" ul ur lr "c")
  86.            (command "pline" (polar ll (angle ll ul) rad) "w" "0" "0"
  87.                             (polar ul (angle ul ll) rad) "a" "d" ul
  88.                             (polar ul (angle ul ur) rad) "l"
  89.                             (polar ur (angle ur ul) rad) "a" "d" ur
  90.                             (polar ur (angle ur lr) rad) "l"
  91.                             (polar lr (angle lr ur) rad) "a" "d" lr
  92.                             (polar lr (angle lr ll) rad) "l"
  93.                             (polar ll (angle ll lr) rad) "a" "d" ll
  94.                             (polar ll (angle ll ul) rad) "cl"))
  95.        (setvar "cmdecho" 1)      
  96.        (setvar "blipmode" 1)
  97.        (princ))
  98.  
  99. (defun butlast (lst)
  100.        (if (and (listp lst) (cdr lst))
  101.            (reverse (cdr (reverse lst))) nil))
  102.  
  103. (defun blobdraw (plist rad / p1 *p* *plist*)
  104.         (setvar "blipmode" 0)
  105.         (setvar "cmdecho" 0)
  106.         (g-draw plist)
  107.         (setq len (length plist)
  108.               p1 (car plist)
  109.               *p1* (polar p1 (angle p1 (cadr plist)) rad))
  110.         (if (/= p1 (last plist))
  111.             (setq *plist* (append (cdr plist) (list p1)))
  112.             (setq *plist* (cdr plist)))
  113.         (command "pline" *p1* 
  114.                  (polar (car *plist*) (angle (car *plist*) p1) rad)
  115.                  "a" "d" (car *plist*))
  116.         (foreach p (butlast (butlast *plist*))
  117.                  (setq *p* (cadr (member p *plist*)))
  118.                  (command (polar p (angle p *p*) rad) "l"
  119.                           (polar *p* (angle *p* p) rad) "a" "d" *p*))
  120.         (command *p1* "cl"))
  121.  
  122.  
  123. ;; BLOB draws n-sided polygons with user specified corner rounding
  124. (defun C:BLOB (/ plist rad pt)
  125.        (graphscr)
  126.        (setvar "coords" 2)
  127.        (setvar "blipmode" 1)
  128.        (setq pt nil
  129.              rad (getdist "\nCorner round radius: "))
  130.        (if rad
  131.            (progn (setq pt (getpoint "\nOrigin point: "))
  132.                   (cond ((not (null pt))
  133.                          (setvar "blipmode" 0)
  134.                          (setq plist (cons pt plist))
  135.                          (setq pt (getpoint (car plist) "\nNext point: "))
  136.                          (grdraw (car plist) pt -1)
  137.                          (setq plist (cons pt plist))
  138.                          (while (and (not (equal (car plist) (car (reverse plist))))
  139.                                 (setq pt (getpoint (car plist) "Next point: ")))
  140.                                 (grdraw (car plist) pt -1)
  141.                                 (setq plist (cons pt plist)))
  142.                          (if (and plist (listp plist) (> (length plist) 2))
  143.                              (blobdraw plist rad)
  144.                              (progn (g-draw plist)
  145.                                     (princ "\nBlob must have at least 3 vertices."))))
  146.                         (T (princ "\nBad point list"))))
  147.             (princ "\nNull radius invalid"))
  148.        (princ))
  149.  
  150. (defun g-draw (pt-list)
  151.        (cond ((< (length pt-list) 2) nil) ;;termination condition
  152.              (T (grdraw (car pt-list) (cadr pt-list) -1)
  153.                 (g-draw (cdr pt-list))))) ;;tail recursion
  154.  
  155. (princ "\nType REC, RECT or BLOB to begin.")
  156. (princ)
  157.  
  158.